home *** CD-ROM | disk | FTP | other *** search
/ Australian Personal Computer 2002 November / CD 1 / APC0211D1.ISO / workshop / prog / files / ActivePerl-5.6.1.633-MSWin32.msi / _3584af9119a9d842a9167ac54c478a63 < prev    next >
Encoding:
Text File  |  2002-05-28  |  12.1 KB  |  432 lines
  1. package PPM::Repository;
  2.  
  3. use strict;
  4. use Data::Dumper;
  5. require PPM::PPD;
  6. require LWP::UserAgent;
  7. use PPM::Archive;
  8. use PPM::Result qw(Ok Warning Error List);
  9. use File::Path qw(rmtree);
  10. use vars qw($VERSION);
  11.  
  12. $VERSION = '3.05';
  13.  
  14. sub new {
  15.     my $this = shift;
  16.     my $class = ref($this) || $this;
  17.     my $self = bless {}, $class;
  18.     my @rest;
  19.     $self->{location} = shift;
  20.     $self->{name} = shift;
  21.     $self->{username} = shift;
  22.     $self->{password} = shift;
  23.  
  24.     my $url = $self->{location};
  25.     $url .= '/' unless substr($url, -1) eq '/';
  26.     $self->{url_base} = URI->new($url);
  27.  
  28.     # All Repositories need a UserAgent to download PPMs, so we might as well
  29.     # initialize it now:
  30.     $self->new_ua;
  31.  
  32.     ($self->{type}, @rest) = select_type($self->{location});
  33.     if ($self->{type} eq 'LOCAL') {
  34.     $self->{dir} = $rest[0];
  35.     require PPM::Repository::Local;
  36.     bless $self, 'PPM::Repository::Local';
  37.     }
  38.     elsif ($self->{type} eq 'WWW') {
  39.     $self->{url} = $rest[0];
  40.     require PPM::Repository::WWW;
  41.     bless $self, 'PPM::Repository::WWW';
  42.     }
  43.     elsif ($self->{type} eq 'PPMSERVER') {
  44.     $self->{client} = $rest[0];
  45.     require PPM::Repository::PPMServer;
  46.     bless $self, 'PPM::Repository::PPMServer';
  47.     }
  48.     elsif ($self->{type} eq 'PPM3SERVER') {
  49.     $self->{client} = $rest[0];
  50.     require PPM::Repository::PPM3Server;
  51.     bless $self, 'PPM::Repository::PPM3Server';
  52.     }
  53.     elsif ($self->{type} eq 'UNSUPPORTED') {
  54.     my $err = PPM::Repository::Result->new($rest[0], $self->{location});
  55.     return (undef, $err->msg_raw);
  56.     }
  57.     $self->init(@_);
  58.     return $self;
  59. }
  60.  
  61. sub select_type {
  62.     my $loc = shift;
  63.     if ($loc =~ m[^file://.*]i) {
  64.         $loc =~ s[^file://][]i;
  65.         $loc =~ s[^localhost/][]i;
  66.         $loc =~ s[\|][:];
  67.     }
  68.     if ($loc =~ m[^\\\\] || $loc =~ m[^//]) {
  69.         return "LOCAL", $loc;
  70.     }
  71.     elsif ($loc =~ m[^[^:]{2,}://]i) {
  72.     if ($loc =~ m[^(http://.*)\?(.*)]i) {
  73.         eval {
  74.         require SOAP::Lite;
  75.         SOAP::Lite->VERSION(0.51);
  76.         };
  77.         return ('UNSUPPORTED', 
  78.             "SOAP-Lite 0.51 is required to support SOAP servers")
  79.           if $@;
  80.         my ($proxy, $uri) = ($1, $2);
  81.         my $client = SOAP::Lite->uri($uri)->proxy($proxy);
  82.  
  83.         # Query the server about its supported version. If it
  84.         # fails, select the "old" ppmserver. If it succeeds, select the
  85.         # "new" ppmserver.
  86.  
  87.         my ($type, $obj) = eval {
  88.         my $soap_result = $client->ppm_protocol;
  89.         my $r = $soap_result->result;
  90.         if (defined $r) {
  91.             my $v = (split /\s+/, $r)[-1];
  92.             return "PPM3SERVER", $client if defined $v and $v >= 300;
  93.             return "PPMSERVER",  $client if defined $v and $v >= 200;
  94.             return "UNSUPPORTED", "Unknown PPM Server protocol '$r'";
  95.         }
  96.         # There's just ONE guy who managed to create a PPM2 server out
  97.         # there, and he doesn't support the ppm_protocol message.
  98.         return "UNSUPPORTED", <<END;
  99. This SOAP server does not expose a PPM3-compatible interface.  Specifically,
  100. it does not implement the ppm_protocol() method.  Please inform the server's
  101. administrator of the problem.
  102. END
  103.         };
  104.  
  105.         return "UNSUPPORTED", "$@" if $@;
  106.         return $type, $obj;
  107.     }
  108.     else {
  109.         return "WWW", $loc;
  110.     }
  111.     }
  112.  
  113.     # The default is to assume it's a local repository
  114.     else {
  115.         return "LOCAL", $loc;
  116.     }
  117. }
  118.  
  119. # Create and initialize an LWP::UserAgent object
  120. sub new_ua {
  121.     my $o = shift;
  122.     return $o->{ua} if $o->{ua};
  123.     $o->{ua} = LWP::UserAgent->new;
  124.     $o->{ua}->agent("ppm/$VERSION");
  125.     $o->init_ua;
  126.     $o->{ua};
  127. }
  128.  
  129. sub init_ua {
  130.     my $o = shift;
  131.     my $ua = shift || $o->{ua};
  132.     $o->{ua}->env_proxy;
  133.     # Special configuration should go here:
  134. }
  135.  
  136. # Create a HTTP::Request object, and authenticate it
  137. sub new_request {
  138.     my $o = shift;
  139.     my $req = HTTP::Request->new(@_);
  140.     my $user = $o->username;
  141.     my $pass = $o->password;
  142.     if (defined $user and defined $pass) {
  143.     $req->authorization_basic($user, $pass);
  144.     }
  145.     # Special headers (HTTP 1.1, keepalive) should go here:
  146.     $req;
  147. }           
  148.  
  149. sub search {
  150.     my $o = shift;
  151.     my $target = shift;
  152.     my $query = shift;
  153.     die "Error: base method PPM::Repository::search() called";
  154. }
  155.  
  156. sub describe {
  157.     my $o = shift;
  158.     my $target = shift;
  159.     my $pkg = shift;
  160.     die "Error: base method PPM::Repository::describe() called";
  161. }
  162.  
  163. sub getppd {
  164.     my $o = shift;
  165.     my $target = shift;
  166.     my $pkg = shift;
  167.     die "Error: base method PPM::Repository::getppd() called";
  168. }
  169.  
  170. # absolutize(): the codebase is potentially relative to the location of the
  171. # PPD, which in turn lives at the base of the repository itself,
  172. # $o->{location}.
  173. sub absolutize {
  174.     my $o = shift;
  175.     my $codebase_rel = shift;
  176.     return URI->new_abs($codebase_rel, $o->{url_base})->as_string;
  177. }
  178.  
  179. # This function is provided so that the three unintelligent subclasses (Local,
  180. # WWW, and PPMServer) know how to find packages when they're asked to find
  181. # modules. This naive function assumes that the package containing a module is
  182. # just the module name with '::' converted to '-'.
  183. sub mod_to_pkg {
  184.     my $o = shift;
  185.     my $module = shift;
  186.     $module =~ s/::/-/g;
  187.     $module;
  188. }
  189.  
  190. # This guarantees to return a "complete" PPM::PPD object based on the actual
  191. # PPD text downloaded from the server.
  192. sub getppd_obj {
  193.     my $o = shift;
  194.     my $target = shift;
  195.     my $pkg = shift;
  196.     $o->describe($target, $pkg);
  197. }
  198.  
  199. sub getppm {
  200.     my $o = shift;
  201.     my $target = shift;
  202.     my $pkg = shift;
  203.     my $tmp = shift;
  204.     my $status_cb = shift;
  205.     my $cb_bytes = shift;
  206.  
  207.     # Calculate the target's name:
  208.     my $tname = $target->name;
  209.  
  210.     # We can't rely on $o->describe() returning a fully-featured PPD object,
  211.     # because the PPM3Server only returns exactly what we need to display for
  212.     # searching and describing. The getppd_obj() method is guaranteed to
  213.     # return a full PPD object, with a codebase.
  214.     my $ppd = $o->getppd_obj($target, $pkg);
  215.     return $ppd unless $ppd->ok;
  216.     $ppd = $ppd->result;
  217.     my $ver = $ppd->version;
  218.     my $impl = $ppd->find_impl($target);
  219.     return $impl unless $impl->ok;
  220.     my $codebase = $impl->result->codebase;
  221.  
  222.     # Make sure the codebase is an absolute URL:
  223.     $codebase = $o->absolutize($codebase, $pkg);
  224.  
  225.     # Create a temporary directory and chdir there:
  226.     (my $filename = $codebase) =~ s|.*/||;
  227.     (my $pkgname = $filename)  =~ s|\..*||;
  228.     my $tmpdir = join '/', $tmp, "$pkgname-$$";
  229.     mkdir $tmpdir or
  230.       return Error("can't create temporary directory '$tmpdir': $!");
  231.  
  232.     use Cwd qw(cwd);
  233.     my $cwd = cwd();
  234.  
  235.     # Neat trick: create a result that, when it goes out of scope, deletes the
  236.     # temporary directory and cleans up on the remote end. If there's an error
  237.     # before we return it, we auto-clean everything up. If we do return it,
  238.     # then it is destroyed after being used by the calling sub.
  239.     my $success_retval = Ok($tmpdir);
  240.     $success_retval->on_destruct(sub {
  241.     rmtree($tmpdir);
  242.     $target->pkgfini($pkg);
  243.     chdir($cwd);
  244.     });
  245.     # Notify the backend that we're going to start processing the files now.
  246.     {
  247.     my $ok = $target->pkginit($pkg);
  248.     return $ok unless $ok->ok;
  249.     }
  250.  
  251.     chdir $tmpdir or
  252.       return Error("can't chdir to $tmpdir: $!");
  253.  
  254.     # Download the tarball:
  255.     my ($bytes, $total, $s_time);
  256.     my $cb = sub {
  257.     my ($data, $res, $prot) = @_;
  258.     $total ||= $res->content_length;
  259.     print FILE $data;
  260.     $bytes += length($data);
  261.  
  262.     # Notify the user through the status callback:
  263.     $status_cb->($pkg, $ver, $tname, 'DOWNLOAD', 
  264.              $bytes, $total, $s_time - time);
  265.     };
  266.     my $ua = $o->{ua};
  267.     my $req = $o->new_request('GET', $codebase);
  268.     open(FILE, '>', $filename) or
  269.       return Error("can't write $filename: $!");
  270.     binmode(FILE) or
  271.       return Error("can't set $filename binary: $!");
  272.     $status_cb->($pkg, $ver, $tname, 'PRE-INSTALL', 0, 0, 0);
  273.     $s_time = time;
  274.     my $res = $ua->request($req, $cb, $cb_bytes);
  275.     $res->is_success or
  276.       return Error("error downloading '$codebase': " . $res->status_line);
  277.     close(FILE) or
  278.       return Error("can't close $filename: $!");
  279.  
  280.     $status_cb->($pkg, $ver, $tname, 'PRE-EXPAND', $total, $total, 0);
  281.     my $ok = eval {
  282.     my $archive = PPM::Archive->new($filename);
  283.     my @files = $archive->list_files;
  284.     my $files = scalar @files;
  285.     my $n = 1;
  286.     for (@files) {
  287.         $status_cb->($pkg, $ver, $tname, 'EXPAND', $n, $files, $_);
  288.         $n++;
  289.         $archive->extract($_);
  290.         next unless -f $_;
  291.         my $ok = $target->transmit($pkg, $_);
  292.         return $ok unless $ok->ok;
  293.     }
  294.     Ok();
  295.     };
  296.     if ($@) {
  297.     return Error("$@"); # stringify it
  298.     }
  299.     return $ok unless $ok->ok;
  300.  
  301.     # Remove the tarball:
  302.     unlink $filename;
  303.  
  304.     # transmit() the install and uninstall scripts to the $target. If it knows
  305.     # how to use them, it will. Otherwise, it won't. YAY!
  306.     for my $thing (qw(install uninstall)) {
  307.     my $method = "${thing}_script";
  308.     my $script = $impl->result->$method;
  309.     next unless $script;
  310.  
  311.     if (my $href = $script->href) {
  312.         $href = $o->absolutize($href, $pkg);
  313.         my $req = $o->new_request('GET', $href);
  314.         my $res = $ua->request($req, $method);
  315.         $res->is_success or return Error(
  316.         "error downloading $thing script '$href': " .
  317.         $res->status_line
  318.         );
  319.     }
  320.     if (-f $method) {
  321.         $target->transmit($pkg, $method);
  322.     }
  323.     }
  324.  
  325.     chdir $cwd;
  326.     return $success_retval;
  327. }
  328.  
  329. sub init { }
  330.  
  331. sub uptodate {
  332.     my $o = shift;
  333.     my $target = shift;
  334.     my $pkg = shift;
  335.     my $version = shift;
  336.     my $ppd = $o->describe($target, $pkg);
  337.     return $ppd unless $ppd->ok;
  338.     List($ppd->result->uptodate($version), $ppd->result->version);
  339. }
  340.  
  341. sub location {
  342.     my $o = shift;
  343.     $o->{location};
  344. }
  345.  
  346. sub name {
  347.     my $o = shift;
  348.     return $o->{name};
  349. }
  350.  
  351. sub username {
  352.     my $o = shift;
  353.     return $o->{username};
  354. }
  355.  
  356. sub password {
  357.     my $o = shift;
  358.     return $o->{password};
  359. }
  360.  
  361. sub type {
  362.     my $o = shift;
  363.     $o->{type};
  364. }
  365.  
  366. sub parse_summary {
  367.     my $o = shift;
  368.     my $doc = shift;
  369.     my $cache_key = shift;
  370.     my $complete = shift;
  371.     $complete = 1 unless defined $complete;
  372.     return Ok($o->{cache}{$cache_key})
  373.       if defined $cache_key and exists $o->{cache}{$cache_key};
  374.     $doc =~ s/<\?xml[^>]+\?>//;
  375.     return Error("could not parse package summary")
  376.       unless $doc =~ /^\s*<REPOSITORYSUMMARY>/;
  377.     $doc =~ s|</?REPOSITORYSUMMARY>||g;
  378.     my %ppds =  map { $_->name, $_ }
  379.         map { @$_{qw(is_complete id)} = ($complete, $_->name); $_ }
  380.         map { $_ .= '</SOFTPKG>'; PPM::PPD->new($_, $o) }
  381.         grep { /\S/ }
  382.         split('</SOFTPKG>', $doc);
  383.     $o->{cache}{$cache_key} = \%ppds
  384.       if defined $cache_key;
  385.     return Ok(\%ppds);
  386. }
  387.  
  388. #=============================================================================
  389. # Profile stuff must be overridden in the PPM3 Server
  390. #=============================================================================
  391. sub profile_list    {
  392.     my $rep = shift;
  393.     my $name = $rep->name;
  394.     my $type = $rep->type_printable;
  395.     Error("Profiles are not supported on the repository '$name'. It is of type '$type', and only 'PPMServer 3.0' or better support profiles.");
  396. }
  397. sub profile_add     { goto &profile_list }
  398. sub profile_del     { goto &profile_list }
  399. sub profile_save    { goto &profile_list }
  400. sub profile_info    { goto &profile_list }
  401. sub profile_target_rename { goto &profile_list }
  402.  
  403. # Profile tracking
  404. sub installed { }
  405. sub upgraded  { }
  406. sub removed   { }
  407.  
  408. package PPM::Repository::Result;
  409. use Data::Dumper;
  410. use PPM::Config;
  411.  
  412. sub new {
  413.     my $p = shift;
  414.     my $msg = shift;
  415.     my $loc = shift;
  416.     my $code = shift || 1;;
  417.     my $site = q{R:\inetpub\wwwroot\www2.ActiveState.com};
  418.  
  419.     # If there's an error about the server being down:
  420.     if ($msg =~ m{\Q$site\E} or $msg =~ m{syntax error}) {
  421.     $msg = "The server '$loc' is not accepting SOAP connections. Please try again later.";
  422.     }
  423.     elsif ($msg =~ /obtaining a license/i) {
  424.     my $file = PPM::Config::get_license_file();
  425.     my $found = -f $file ? "is present" : "not found";
  426.     $msg = join ' ', $msg, "License file '$file' $found.";
  427.     }
  428.     return PPM::Result->new('', $code, $msg);
  429. }
  430.  
  431. 1;
  432.